home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / PASWIZ20 / BCD.PAS < prev    next >
Pascal/Delphi Source File  |  1994-11-04  |  14KB  |  583 lines
  1. {   +----------------------------------------------------------------------+
  2.     |                                                                      |
  3.     |        PasWiz  Copyright (c) 1990-1994  Thomas G. Hanlin III         |
  4.     |                                                                      |
  5.     +----------------------------------------------------------------------+
  6.  
  7.  
  8.  
  9. BCD math:
  10.  
  11.    This collection of routines provides powerful support for BCD math.
  12.    Numbers may be up to 255 digits long, with a decimal point anywhere
  13.    you want it.  Trig and other advanced functions are provided as well
  14.    as the more prosaic multiply, divide, subtract, and add.
  15.  
  16. }
  17.  
  18.  
  19.  
  20. UNIT BCD;
  21.  
  22.  
  23.  
  24. INTERFACE
  25.  
  26.  
  27.  
  28. VAR
  29.    LeftD, RightD: Integer;
  30.  
  31.  
  32.  
  33. FUNCTION BCDAbs (Nr: String): String;
  34. FUNCTION BCDAdd (Nr1, Nr2: String): String;
  35. FUNCTION BCDCompare (Nr1, Nr2: String): Integer;
  36. FUNCTION BCDCos (Nr: String): String;
  37. FUNCTION BCDCot (Nr: String): String;
  38. FUNCTION BCDCsc (Nr: String): String;
  39. FUNCTION BCDDeg2Rad (Nr: String): String;
  40. FUNCTION BCDDiv (Nr1, Nr2: String): String;
  41. FUNCTION BCDe: String;
  42. FUNCTION BCDFact (Num: Integer): String;
  43. FUNCTION BCDFormat (Nr: String; FormatType, RightDigits: Integer): String;
  44. FUNCTION BCDFrac (Nr: String): String;
  45. FUNCTION BCDInt (Nr: String): String;
  46. FUNCTION BCDMul (Nr1, Nr2: String): String;
  47. FUNCTION BCDNeg (Nr: String): String;
  48. FUNCTION BCDpi: String;
  49. FUNCTION BCDPower (Nr: String; Power: Integer): String;
  50. FUNCTION BCDRad2Deg (Nr: String): String;
  51. FUNCTION BCDSec (Nr: String): String;
  52. FUNCTION BCDSet (NumSt: String): String;
  53. FUNCTION BCDSgn (Nr: String): Integer;
  54. FUNCTION BCDSin (Nr: String): String;
  55. FUNCTION BCDSqrt (Nr: String): String;
  56. FUNCTION BCDSub (Nr1, Nr2: String): String;
  57. FUNCTION BCDTan (Nr: String): String;
  58.  
  59.  
  60.  
  61.  
  62. { --------------------------------------------------------------------------- }
  63.  
  64.  
  65.  
  66. IMPLEMENTATION
  67.  
  68.  
  69.  
  70. {$F+}
  71.  
  72. { various helper routines in assembly language }
  73.  
  74. PROCEDURE BCDAdd1 (VAR Nr1: String; Nr2: String); external;
  75. PROCEDURE BCDDiv1L (VAR Nr: String); external;
  76. PROCEDURE BCDDiv1R (VAR Nr: String); external;
  77. PROCEDURE BCDMul1 (VAR Nr: String; Multiplier: Byte); external;
  78. PROCEDURE BCDSub1 (VAR Nr: String); external;
  79.  
  80. FUNCTION BCDAbs; external;
  81. FUNCTION BCDSgn; external;
  82.  
  83. {$L BCDABS}
  84. {$L BCDADD1}
  85. {$L BCDDIV1L}
  86. {$L BCDDIV1R}
  87. {$L BCDMUL1}
  88. {$L BCDSGN}
  89. {$L BCDSUB1}
  90.  
  91.  
  92.  
  93. { local function: complement a number }
  94. FUNCTION Complement (Nr: String): String;
  95. VAR
  96.    St: String;
  97. BEGIN
  98.    St := Nr;
  99.    BCDSub1(St);
  100.    Complement := St;
  101. END;
  102.  
  103.  
  104.  
  105. { local func: create a string of nulls }
  106. FUNCTION NullDupe (DupeCount: Integer): String;
  107. VAR
  108.    tmp: Integer;
  109.    St: String;
  110. BEGIN
  111.    St := '';
  112.    FOR tmp := 1 TO DupeCount DO
  113.       St := St + CHR(0);
  114.    NullDupe := St;
  115. END;
  116.  
  117.  
  118.  
  119. { addition }
  120. FUNCTION BCDAdd (Nr1, Nr2: String): String;
  121. VAR
  122.    Sign1, Sign2, N1, N2: String;
  123. BEGIN
  124.    Sign1 := Copy(Nr1, 1, 1);
  125.    Sign2 := Copy(Nr2, 1, 1);
  126.    N1 := Copy(Nr1, 2, 255);
  127.    N2 := Copy(Nr2, 2, 255);
  128.    IF (Sign1 = Sign2) THEN BEGIN
  129.       BCDAdd1 (N1, N2);
  130.       BCDAdd := Sign1 + N1; END
  131.    ELSE IF (Sign1 = '-') THEN
  132.       BCDAdd := BCDSub(Nr2, ' ' + N1)
  133.    ELSE
  134.       BCDAdd := BCDSub(Nr1, ' ' + N2);
  135. END;
  136.  
  137.  
  138.  
  139. { compare two numbers }
  140. FUNCTION BCDCompare (Nr1, Nr2: String): Integer;
  141. VAR
  142.    Sign1, Sign2: String;
  143. BEGIN
  144.    Sign1 := Copy(Nr1, 1, 1);
  145.    Sign2 := Copy(Nr2, 1, 1);
  146.    IF Sign1 = Sign2 THEN
  147.       BCDCompare := BCDSgn(BCDSub(' ' + Copy(Nr1, 2, 255), ' ' + Copy(Nr2, 2, 255)))
  148.    ELSE IF (Sign1 = '-') THEN
  149.       BCDCompare := -1
  150.    ELSE
  151.       BCDCompare := 1;
  152. END;
  153.  
  154.  
  155.  
  156. { cosine }
  157. FUNCTION BCDCos (Nr: String): String;
  158. VAR
  159.    One, Two, St, Result, I, X2: String;
  160. BEGIN
  161.    One := BCDSet('1');
  162.    Two := BCDSet('2');
  163.    St := One;
  164.    Result := One;
  165.    I := Two;
  166.    X2 := BCDMul(Nr, Nr);
  167.    WHILE BCDSgn(St) <> 0 DO BEGIN
  168.       St := BCDNeg(BCDDiv(BCDMul(St, X2), BCDMul(I, BCDSub(I, One))));
  169.       Result := BCDAdd(Result, St);
  170.       I := BCDAdd(I, Two);
  171.    END;
  172.    BCDCos := Result;
  173. END;
  174.  
  175.  
  176.  
  177. { cotangent }
  178. FUNCTION BCDCot (Nr: String): String;
  179. BEGIN
  180.    BCDCot := BCDDiv(BCDCos(Nr), BCDSin(Nr));
  181. END;
  182.  
  183.  
  184.  
  185. { cosecant }
  186. FUNCTION BCDCsc (Nr: String): String;
  187. BEGIN
  188.    BCDCsc := BCDDiv(BCDSet('1'), BCDSin(Nr));
  189. END;
  190.  
  191.  
  192.  
  193. { convert degrees to radians }
  194. FUNCTION BCDDeg2Rad (Nr: String): String;
  195. BEGIN
  196.    BCDDeg2Rad := BCDDiv(BCDMul(Nr, BCDpi), BCDSet('180'));
  197. END;
  198.  
  199.  
  200.  
  201. { division }
  202. FUNCTION BCDDiv (Nr1, Nr2: String): String;
  203. VAR
  204.    Sign1, Sign2, N1, N2, Result, ShiftTrack: String;
  205.    Flip, Ready: Boolean;
  206. BEGIN
  207.    IF BCDSgn(Nr2) = 0 THEN
  208.       BCDDiv := ''
  209.    ELSE IF BCDSgn(Nr1) = 0 THEN
  210.       BCDDiv := Nr1
  211.    ELSE BEGIN
  212.       Sign1 := Copy(Nr1, 1, 1);
  213.       Sign2 := Copy(Nr2, 1, 1);
  214.       N1 := BCDAbs(Nr1);
  215.       N2 := BCDAbs(Nr2);
  216.       Result := BCDSet('0');
  217.       ShiftTrack := BCDSet('1');
  218.       REPEAT
  219.          Flip := FALSE;
  220.          Ready := FALSE;
  221.          REPEAT
  222.             CASE BCDCompare(N2, N1) OF
  223.                -1: BEGIN
  224.                       BCDDiv1L(N2);
  225.                       BCDDiv1L(ShiftTrack);
  226.                       Flip := TRUE;
  227.                    END;
  228.                 0: Ready := TRUE;
  229.                 1: BEGIN
  230.                       BCDDiv1R(N2);
  231.                       BCDDiv1R(ShiftTrack);
  232.                       Ready := Flip;
  233.                    END;
  234.             END;
  235.             IF BCDSgn(ShiftTrack) = 0 THEN Ready := TRUE;
  236.          UNTIL Ready;
  237.          Result := BCDAdd(Result, ShiftTrack);
  238.          N1 := BCDSub(N1, N2);
  239.       UNTIL (BCDSgn(ShiftTrack) = 0) OR (BCDSgn(N1) = 0);
  240.       IF Sign1 = Sign2 THEN
  241.          BCDDiv := Sign1 + Copy(Result, 2, 255)
  242.       ELSE
  243.          BCDDiv := '-' + Copy(Result, 2, 255);
  244.    END;
  245. END;
  246.  
  247.  
  248.  
  249. { the constant "e" }
  250. FUNCTION BCDe: String;
  251. VAR
  252.    St: String;
  253. BEGIN
  254.    St := '2.718281828459045235360287471352662497757247093699959574966';
  255.    St := St + '9676277240766303535475945713821785251664274274663919320031';
  256.    BCDe := BCDSet(St);
  257. END;
  258.  
  259.  
  260.  
  261. { factorial }
  262. FUNCTION BCDFact (Num: Integer): String;
  263. VAR
  264.    One, Result, Mult: String;
  265.    N: Integer;
  266. BEGIN
  267.    One := BCDSet('1');
  268.    Result := One;
  269.    Mult := BCDSet('2');
  270.    FOR N := 2 TO Num DO BEGIN
  271.       Result := BCDMul(Result, Mult);
  272.       Mult := BCDAdd(Mult, One);
  273.    END;
  274.    BCDFact := Result;
  275. END;
  276.  
  277.  
  278.  
  279. { format a number into a text string }
  280. FUNCTION BCDFormat (Nr: String; FormatType, RightDigits: Integer): String;
  281. VAR
  282.   L, R, Sign, T, St: String;
  283.   tmp, ch: Integer;
  284. BEGIN
  285.    Sign := Copy(Nr, 1, 1);
  286.    L := Copy(Nr, 2, LeftD);
  287.    R := Copy(Nr, Length(Nr) - RightD + 1, RightD);
  288.    WHILE Copy(L, 1, 1) = CHR(0) DO
  289.       L := Copy(L, 2, 255);
  290.    IF Length(L) = 0 THEN
  291.       L := CHR(0);
  292.    IF Odd(FormatType) AND (Length(L) > 3) THEN BEGIN
  293.       T := Copy(L, 1, Length(L) - 3);
  294.       L := Copy(L, Length(L) - 2, 3);
  295.       WHILE Length(T) > 3 DO BEGIN
  296.          L := Copy(T, Length(T) - 2, 3) + ',' + L;
  297.          T := Copy(T, 1, Length(T) - 3);
  298.       END;
  299.       L := T + ',' + L;
  300.       IF Copy(L, 1, 1) = ',' THEN L := Copy(L, 2, 255);
  301.    END;
  302.    IF Odd(FormatType SHR 1) THEN
  303.       L := '$' + L;
  304.    IF Odd(FormatType SHR 3) AND (Sign = ' ') THEN
  305.       Sign := '+';
  306.    R := Copy(R, 1, Abs(RightDigits));
  307.    IF RightDigits < 0 THEN
  308.       WHILE Copy(R, Length(R), 1) = CHR(0) DO
  309.          R := Copy(R, 1, Length(R) - 1);
  310.    IF Odd(FormatType SHR 2) THEN
  311.       R := R + Sign
  312.    ELSE
  313.       L := Sign + L;
  314.    St := L + '.' + R;
  315.    IF RightDigits = 0 THEN BEGIN
  316.       tmp := Pos('.', St);
  317.       St := Copy(St, 1, tmp - 1) + Copy(St, tmp + 1, 255);
  318.    END;
  319.    FOR tmp := 1 TO Length(St) DO BEGIN
  320.       ch := ORD(St[tmp]);
  321.       IF ch < 10 THEN
  322.          St[tmp] := CHR(ch + 48);
  323.    END;
  324.    BCDFormat := St;
  325. END;
  326.  
  327.  
  328.  
  329. { keep only the digits to the right of the decimal point }
  330. FUNCTION BCDFrac (Nr: String): String;
  331. VAR
  332.    St: String;
  333.    tmp: Integer;
  334. BEGIN
  335.    St := BCDFormat(Nr, 0, RightD);
  336.    tmp := Pos('.', St);
  337.    IF tmp > 0 THEN
  338.       St := '0' + Copy(St, tmp, 255)
  339.    ELSE
  340.       St := '0';
  341.    BCDFrac := BCDSet(St);
  342. END;
  343.  
  344.  
  345.  
  346. { keep only the digits to the left of the decimal point }
  347. FUNCTION BCDInt (Nr: String): String;
  348. BEGIN
  349.    BCDInt := BCDSet(BCDFormat(Nr, 0, 0));
  350. END;
  351.  
  352.  
  353.  
  354. { multiply }
  355. FUNCTION BCDMul (Nr1, Nr2: String): String;
  356. VAR
  357.    ch: Byte;
  358.    TotalD, tmp2, ShiftVal: Integer;
  359.    Sign, N1, N2, Total, St: String;
  360. BEGIN
  361.    TotalD := LeftD + RightD;
  362.    IF Copy(Nr1, 1, 1) = Copy(Nr2, 1, 1) THEN
  363.       Sign := ' '
  364.    ELSE
  365.       Sign := '-';
  366.    N1 := Copy(Nr1, 2, 255);
  367.    N2 := Copy(Nr2, 2, 255);
  368.    Total := BCDSet('0');
  369.    FOR tmp2 := Length(N2) DOWNTO 1 DO BEGIN
  370.       ch := ORD(N2[tmp2]);
  371.       IF ch <> 0 THEN BEGIN
  372.          St := N1;
  373.          BCDMul1(St, ch);
  374.          IF tmp2 > TotalD - RightD THEN BEGIN
  375.             ShiftVal := RightD - (TotalD - tmp2);
  376.             St := ' ' + NullDupe(ShiftVal) + Copy(St, 1, Length(St) - ShiftVal);
  377.          END
  378.          ELSE BEGIN
  379.             ShiftVal := LeftD - tmp2;
  380.             St := ' ' + Copy(St, ShiftVal + 1, 255) + NullDupe(ShiftVal);
  381.          END;
  382.          Total := BCDAdd(Total, St);
  383.       END;
  384.    END;
  385.    BCDMul := Sign + Copy(Total, 2, 255);
  386. END;
  387.  
  388.  
  389.  
  390. { negate }
  391. FUNCTION BCDNeg (Nr: String): String;
  392. BEGIN
  393.    CASE BCDSgn(Nr) OF
  394.       -1: BCDNeg := ' ' + Copy(Nr, 2, 255);
  395.        0: BCDNeg := Nr;
  396.        1: BCDNeg := '-' + Copy(Nr, 2, 255);
  397.    END;
  398. END;
  399.  
  400.  
  401.  
  402. { the constant "pi" }
  403. FUNCTION BCDpi: String;
  404. VAR
  405.    St: String;
  406. BEGIN
  407.    St := '3.1415926535897932384626433832795028841971';
  408.    St := St + '6939937510582097494459230781640628620899';
  409.    St := St + '8628034825342117067982148086513282306647';
  410.    St := St + '0938446095505822317253594081284811174502';
  411.    St := St + '8410270193852110555964462294895493038196';
  412.    St := St + '4428810975665933446128475648233786783165';
  413.    St := St + '2712019091456';
  414.    BCDpi := BCDSet(St);
  415. END;
  416.  
  417.  
  418.  
  419. { raise a number to a power }
  420. FUNCTION BCDPower (Nr: String; Power: Integer): String;
  421. VAR
  422.    P: Integer;
  423.    Sign, PSeq, Result: String;
  424. BEGIN
  425.    IF Power <= 0 THEN
  426.       BCDPower := BCDSet('1')
  427.    ELSE BEGIN
  428.       Sign := Copy(Nr, 1, 1);
  429.       P := Power;
  430.       Result := BCDSet('1');
  431.       PSeq := BCDAbs(Nr);
  432.       WHILE P > 0 DO BEGIN
  433.          IF Odd(P) THEN Result := BCDMul(Result, PSeq);
  434.          P := P DIV 2;
  435.          PSeq := BCDMul(PSeq, PSeq);
  436.       END;
  437.       IF Odd(Power) THEN
  438.          BCDPower := Sign + Copy(Result, 2, 255)
  439.       ELSE
  440.          BCDPower := Result;
  441.    END;
  442. END;
  443.  
  444.  
  445.  
  446. { convert radians to degrees}
  447. FUNCTION BCDRad2Deg (Nr: String): String;
  448. BEGIN
  449.    BCDRad2Deg := BCDDiv(BCDMul(Nr, BCDSet('180')), BCDpi);
  450. END;
  451.  
  452.  
  453.  
  454. { secant }
  455. FUNCTION BCDSec (Nr: String): String;
  456. BEGIN
  457.    BCDSec := BCDDiv(BCDSet('1'), BCDCos(Nr));
  458. END;
  459.  
  460.  
  461.  
  462. { convert a text string to a BCD number }
  463. FUNCTION BCDSet (NumSt: String): String;
  464. VAR
  465.    tmp, ch: Integer;
  466.    St, Sign, L, R: String;
  467. BEGIN
  468.    St := NumSt;
  469.    WHILE Copy(St, 1, 1) = ' ' DO
  470.       St := Copy(St, 2, 255);
  471.    WHILE Copy(St, Length(St), 1) = ' ' DO
  472.       St := Copy(St, 1, Length(St) - 1);
  473.    FOR tmp := 1 TO Length(St) DO BEGIN
  474.       ch := ORD(St[tmp]);
  475.       IF (ch >= 48) AND (ch <= 57) THEN
  476.          St[tmp] := CHR(ch - 48);
  477.    END;
  478.    IF Copy(St, 1, 1) = '-' THEN BEGIN
  479.       Sign := '-';
  480.       St := Copy(St, 2, 255);
  481.    END
  482.    ELSE
  483.       Sign := ' ';
  484.    tmp := Pos('.', St);
  485.    IF tmp > 0 THEN BEGIN
  486.       L := Copy(St, 1, tmp - 1);
  487.       R := Copy(St, tmp + 1, 255);
  488.    END
  489.    ELSE BEGIN
  490.       L := St;
  491.       R := '';
  492.    END;
  493.    L := NullDupe(LeftD) + L;
  494.    L := Copy(L, Length(L) - LeftD + 1, LeftD);
  495.    R := Copy(R + NullDupe(RightD), 1, RightD);
  496.    BCDSet := Sign + L + R;
  497. END;
  498.  
  499.  
  500.  
  501. { sine }
  502. FUNCTION BCDSin (Nr: String): String;
  503. VAR
  504.    St, Result, One, Two, I, X2: String;
  505. BEGIN
  506.    St := Nr;
  507.    Result := Nr;
  508.    One := BCDSet('1');
  509.    Two := BCDSet('2');
  510.    I := BCDSet('3');
  511.    X2 := BCDMul(Nr, Nr);
  512.    WHILE BCDSgn(St) <> 0 DO BEGIN
  513.       St := BCDNeg(BCDDiv(BCDMul(St, X2), BCDMul(I, BCDSub(I, One))));
  514.       Result := BCDAdd(Result, St);
  515.       I := BCDAdd(I, Two);
  516.    END;
  517.    BCDSin := Result;
  518. END;
  519.  
  520.  
  521.  
  522. { square root }
  523. FUNCTION BCDSqrt (Nr: String): String;
  524. VAR
  525.    Two, Est1, Est2: String;
  526. BEGIN
  527.    IF Copy(Nr, 1, 1) = '-' THEN
  528.       BCDSqrt := ''
  529.    ELSE BEGIN
  530.       Two := BCDSet('2');
  531.       Est2 := BCDDiv(Nr, Two);
  532.       REPEAT
  533.          Est1 := Est2;
  534.          Est2 := BCDDiv(BCDAdd(Est1, BCDDiv(Nr, Est1)), Two);
  535.       UNTIL BCDCompare(Est1, Est2) = 0;
  536.       BCDSqrt := Est2;
  537.    END;
  538. END;
  539.  
  540.  
  541.  
  542. { subtraction }
  543. FUNCTION BCDSub (Nr1, Nr2: String): String;
  544. VAR
  545.    Sign1, Sign2, N1, N2: String;
  546. BEGIN
  547.    Sign1 := Copy(Nr1, 1, 1);
  548.    Sign2 := Copy(Nr2, 1, 1);
  549.    N1 := Copy(Nr1, 2, 255);
  550.    N2 := Copy(Nr2, 2, 255);
  551.    IF Sign1 = Sign2 THEN BEGIN
  552.       BCDAdd1(N1, Complement(N2));
  553.       IF ORD(N1[1]) = 9 THEN
  554.          IF Sign1 = '-' THEN
  555.             N1 := ' ' + Complement(N1)
  556.          ELSE
  557.             N1 := '-' + Complement(N1)
  558.       ELSE
  559.          N1 := Sign1 + N1;
  560.       BCDSub := N1;
  561.    END
  562.    ELSE BEGIN
  563.       BCDAdd1(N1, N2);
  564.       BCDSub := Sign1 + N1;
  565.    END;
  566. END;
  567.  
  568.  
  569.  
  570. { tangent }
  571. FUNCTION BCDTan (Nr: String): String;
  572. BEGIN
  573.    BCDTan := BCDDiv(BCDSin(Nr), BCDCos(Nr));
  574. END;
  575.  
  576.  
  577.  
  578. { ----------------------- initialization code --------------------------- }
  579. BEGIN
  580.    LeftD := 20;          { digits to the left of the decimal }
  581.    RightD := 11;         { digits to the right of the decimal }
  582. END.
  583.